iT邦幫忙

2019 iT 邦幫忙鐵人賽

DAY 19
1
自我挑戰組

Access VBA 之 iT管理實做系列 第 19

Access VBA 之 iT管理實做Day19: 樹狀結構應用-硬體表

  • 分享至 

  • xImage
  •  

TreeView樹狀圖結構物件雖然存在於Access 中,但並沒有太詳細的說明,筆者到最近才開始嘗試使用,個人感覺設計上並不太友善,但還是有一定的使用效果。
筆者參考了Stephen Hill撰寫的教程,一步步進行編寫,使用現有的資料來產生樹狀圖,可以有更視覺化呈現。

程式呈現如下圖:
https://ithelp.ithome.com.tw/upload/images/20181103/200072215DM5JP31BA.png

「讀取/篩選」按鈕的程式如下:

Private Sub cmd_Search_Click()
    xMyTreeview.nodes.Clear
    SetUpImageList
    SetUpContextMenu
    AddAllNodes
    
End Sub

Private Sub SetUpImageList()
    Dim strFolder As String
    
    ' retreive the database's folder as the folder for the images
    'strFolder = CurrentProject.Path & "\"
    strFolder = "D:\temp\vba\"
    
    With Me.xMyTreeviewImages
        With .ListImages
            .Clear
            ' load images to image list, specifying a key that will be used to connect the image
            ' to the nodes later on
            ' each image has to be converted to picture data using LoadPicture()
            
            ' Customer and Order nodes will use a picture appropriate to the type of node
            .Add key:="Customer", Picture:=LoadPicture(strFolder & "Customer.bmp")
            .Add key:="Order", Picture:=LoadPicture(strFolder & "Order.bmp")
            
            ' Order line nodes will use an image that relates to the product's category, keyed
            ' using the category's name
            .Add key:="Beverages", Picture:=LoadPicture(strFolder & "Beverages.bmp")
            .Add key:="Condiments", Picture:=LoadPicture(strFolder & "Condiments.bmp")
            .Add key:="Confections", Picture:=LoadPicture(strFolder & "Confections.bmp")
            .Add key:="Dairy Products", Picture:=LoadPicture(strFolder & "Dairy Products.bmp")
            .Add key:="Grains/Cereals", Picture:=LoadPicture(strFolder & "Grains.bmp")
            .Add key:="Meat/Poultry", Picture:=LoadPicture(strFolder & "Meat.bmp")
            .Add key:="Produce", Picture:=LoadPicture(strFolder & "Produce.bmp")
            .Add key:="Seafood", Picture:=LoadPicture(strFolder & "Seafood.bmp")
        End With
    End With
End Sub

Public Sub SetUpContextMenu()
  ' requires a reference to the Microsoft office object library

  On Error Resume Next ' ignore error if command bar does not exist to be deleted
  CommandBars("MyTreeviewContextMenu").Delete
  On Error GoTo 0

  With CommandBars.Add(Name:="MyTreeviewContextMenu", Position:=msoBarPopup)
    With .Controls.Add(TYPE:=msoControlButton)
      .Caption = "Node Details"
      .OnAction = "PopUpNodeDetails"
    End With
    With .Controls.Add(TYPE:=msoControlButton)
      .Caption = "Delete Node"
      .OnAction = "PopUpNodeDelete"
    End With
  End With
End Sub


Private Sub AddAllNodes()
    Dim rst As DAO.Recordset ' recordset for category and product data
    
    Dim strCategoryNodeKey ' key for this category node
    Dim strProductNodeKey
    Dim strOldCategoryKey As String ' for detecting change in category
    Dim strOldProductNodeKey As String
    
    If isNothing(Combo_lng) Then
        strLng = "CHT"
    Else
        strLng = Combo_lng
    End If
    
    If isNothing(Text_Search) = False Then
        strWhere = " WHERE C.NAME_" & strLng & " LIKE '*" & Text_Search & "*' OR CS.NAME_" & strLng & " LIKE '*" & Text_Search & "*' OR I.MARK LIKE '*" & Text_Search & "*' OR I.MODEL LIKE '*" & Text_Search & "*' OR I.TYPE LIKE '*" & Text_Search & "*' OR I.[S/N] LIKE '*" & Text_Search & "*' "
    End If
    strSQL = "" & _
    "SELECT C.INDEX AS CK, C.NAME_" & strLng & " AS CNAME, CS.INDEX AS CSK, CS.NAME_" & strLng & " AS CSNAME, I.INDEX AS IK, I.MARK, I.MODEL, I.TYPE, I.[S/N], I.STATUS_ID " & vbCrLf & _
    "FROM (CategoryType AS C LEFT JOIN CategorySubType AS CS ON C.INDEX = CS.CategoryType_INDEX) LEFT JOIN InventoryOfProperty AS I ON CS.INDEX = I.CATEGORY " & vbCrLf & _
    strWhere & _
    "ORDER BY C.NAME_" & strLng & ", CS.NAME_" & strLng & ", I.MARK, I.MODEL, I.TYPE "
    Debug.Print strSQL
    ' open the recordset
    Set rst = CurrentDb.OpenRecordset(strSQL)
   
    ' loop through the rows in the recordset
    If rst.EOF Then Exit Sub
    rst.MoveFirst
    Do Until rst.EOF
        
        strCategoryNodeKey = "Cat=" & rst!CK
        
        If strCategoryNodeKey <> strOldCategoryKey Then ' check for change in category
            ' change in category- add category node
            With Me.xMyTreeview.nodes.Add(text:=rst!CNAME, key:=strCategoryNodeKey, Image:="Customer")
                .Expanded = True
            End With
            
            strOldCategoryKey = strCategoryNodeKey ' remember this as the current key for detecting changes
        End If
            
        strProductNodeKey = "Prod=" & rst!CSK
        
        If strCategoryNodeKey & strProductNodeKey <> strOldCategoryKey & strOldProductNodeKey Then ' check for change in category
            ' change in category- add category node
            With Me.xMyTreeview.nodes.Add(Relationship:=tvwChild, Relative:=strCategoryNodeKey, text:=rst!CSName, key:=strProductNodeKey, Image:="Order")
                .Expanded = True
            End With
            strOldProductNodeKey = strProductNodeKey ' remember this as the current key for detecting changes
        End If
                    
        If IsNull(rst!IK) = False Then
            strItemNodeKey = "Item=" & rst!IK
            
            ' now add product node
            Debug.Print rst![S/N]
            With Me.xMyTreeview.nodes.Add(Relationship:=tvwChild, Relative:=strProductNodeKey, _
                    text:=rst!Mark & "(" & rst!Model & "/" & rst!TYPE & "/" & rst![S/N] & ")", key:=strItemNodeKey, Image:="Confections")
        
                If rst![STATUS_ID] = 1 Or rst![STATUS_ID] = 7 Or rst![STATUS_ID] = 10 Then
                  .ForeColor = vbGrayText
                End If
            End With
            
        End If
        
        rst.MoveNext ' next record in qeury
    Loop
End Sub

參考網站:
My MS Access Blog
http://MyMSAccessBlog.blogspot.com


上一篇
Access VBA 之 iT管理實做Day18: 硬體資料匯出-匯出硬體表
下一篇
Access VBA 之 iT管理實做Day20: 自定義程式-確認數值無值
系列文
Access VBA 之 iT管理實做30
圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

尚未有邦友留言

立即登入留言